home *** CD-ROM | disk | FTP | other *** search
/ Tech Arsenal 1 / Tech Arsenal (Arsenal Computer).ISO / tek-11 / clp123.zip / 123.PRG next >
Text File  |  1992-05-25  |  7KB  |  237 lines
  1. /*
  2. █▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀█
  3. █                                                                              █
  4. █ MODULE     : 123.prg                                                         █
  5. █ AUTHOR     : jON Rowlan S.A.D.S. Ltd. 1989, 1990, 1991                       █
  6. █              Hunton, Maidstone England 44 6272 688/748                       █
  7. █                      (from 28/05/92 0622 820688 & 820748 )                   █
  8. █              Compuserve : 100013,475                                         █
  9. █                                                                              █
  10. █ PARAMETERS : none                                                            █
  11. █                                                                              █
  12. █ description : This is a self contained module that will create a Lotus       █
  13. █               WKS/WK1 style spreadsheet from an array of character and       █
  14. █               numeric data. Numerics are converted to the IEEE format as     █
  15. █               used by Lotus. I would be pleased to hear of any enhancements  █
  16. █               comments or :-( 'BUGS' but if the module is used in any        █
  17. █               application the copyright notice as bordered by this box must  █
  18. █               be included in the source. If any modifications are required   █                                                                            █
  19. █               I will be happy to do these for 'The usual fee plus expenses'. █
  20. █               At the end of the day, I will be happy if this module helps    █
  21. █               save somebody the hassle I had in trying to put it together    █
  22. █               when asked by my client, "Can we export to Lotus ???!!???".    █
  23. █               The IEEE conversion routine can be reworked with Funcky's      █
  24. █               or() and and() functions. Bon Chance!                          █
  25. █                                                                              █
  26. █ Compile with : /n                                                            █
  27. █                                                                              █
  28. █ Link with    : whatever you fancy                                            █
  29. █                                                                              █
  30. █▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄█*/
  31.  
  32.  
  33. #define WKS_BOF          chr(0)+chr(0)+chr(2)+chr(0)+chr(4)+chr(4)
  34. #define WKS_EOF          chr(1)+chr(0)+chr(0)+chr(0)
  35. #define WKS_LABELHDR     chr(15)+chr(0)
  36. #define WKS_NUMBERHDR    chr(14)+chr(0)+chr(13)+chr(0)
  37.  
  38. #define LEFT_JUSTIFY     "'"
  39. #define RIGHT_JUSTIFY    chr(34)
  40. #define CENTERED         "^"
  41. #define REPEATING        "\"
  42. #define PROTECTED        chr(128)
  43. #define UNPROTECTED      chr(0)
  44. #define FIXED            0
  45. #define SCIENTIFIC       1
  46. #define CURRENCY         2
  47. #define PERCENT          3
  48. #define COMMA            4
  49. #define UNUSED1          5
  50. #define UNUSED2          6
  51. #define SPECIAL          7
  52. #define STANDARD_FORMAT  chr(255)
  53.  
  54. #command CLOSE WORKSHEET => fwrite( WKSHandle, WKS_EOF ) ; fclose( WKSHandle )
  55.  
  56. #command CREATE WORKSHEET <(worksheetname)> FROM ARRAY <arrayname> =>           ;
  57.      WKScreate( <(worksheetname)>, @<arrayname> )
  58.  
  59. #command CREATE WORKSHEET <worksheetname> =>                                  ;
  60.      WKSHandle := fcreate( <worksheetname> )                             ;;
  61.      fwrite( WKSHandle, WKS_BOF )
  62.  
  63. STATIC WKSHandle
  64.  
  65.  
  66. FUNCTION WKSexample()
  67.  
  68.     LOCAL worksheet:={ { "Year", "Premiums" },                            ;
  69.                { 1978, 15526, 26625, -9918, 128827, 12762, 187 }, ;
  70.                { 1979, 16651, -900, 12772, 91881, -1298222 },     ;
  71.                { 1980, 177111, 19918, -18716, 1222 },             ;
  72.                { 1981, 12650932, 18827, 998 },                    ;
  73.                { 1982, 166154, 12 },                              ;
  74.                { 1983, 1652, 15 },                                ;
  75.                { 1984, 1.87, .7 },                                ;
  76.                { 1985, 0.27 } }
  77.  
  78.     CREATE WORKSHEET lotus FROM ARRAY worksheet
  79.  
  80.     ?"Done."
  81.  
  82. return( NIL )
  83.  
  84. FUNCTION WKSCreate( WKSFileName, WorkSheet )
  85.  
  86.     LOCAL col, row
  87.  
  88. // Create WKS type file //
  89.  
  90.     if !( "." $ WKSFileName )
  91.         WKSFileName := WKSFileName+".WKS"
  92.     endif
  93.  
  94.     CREATE WORKSHEET WKSFileName
  95.  
  96.     for row=1 to len(WorkSheet)
  97.         for col=1 to len(WorkSheet[row])
  98.             do case
  99.                 case valtype( worksheet[row,col] ) == "C"
  100.                     WKSWriteStr( WorkSheet[row, col], "L", row, col )
  101.                 case valtype( worksheet[row,col] ) == "N"
  102.                     WKSWriteNum( WorkSheet[row, col], row, col )
  103.             endcase
  104.         next
  105.     next
  106.  
  107.     CLOSE WORKSHEET
  108.  
  109. return( NIL )
  110.  
  111. FUNCTION WKSwritestr( ostr, just, row, col )
  112.  
  113.     LOCAL r
  114.  
  115.     just := upper( just )
  116.     ostr := trim( ostr )
  117.  
  118. // if ostr is blank, return //
  119.  
  120.     if ostr == ""
  121.         return( .t. )
  122.     endif
  123.  
  124. // Text label header, 2 chars //
  125.  
  126.     r := fwrite( WKSHandle, WKS_LABELHDR )
  127.  
  128. // Text Label length, 2 chars //
  129.  
  130.     r := r + fwrite( WKSHandle, chr( ( len( trim( ostr ) ) + 7 ) % 256 ) )
  131.     r := r + fwrite( WKSHandle, chr( ( len( trim( ostr ) ) + 7 ) / 256 ) )
  132.  
  133. // default cell format, 1 char //
  134.  
  135.     r := r + fwrite( WKSHandle, STANDARD_FORMAT )
  136.  
  137. // cell co-ordinates, 4 chars total ( numbers in reverse byte format ! ) //
  138.  
  139.     r := r + WKScoord( row, col )
  140.  
  141. // Justification, 1 char //
  142.  
  143.     do case                                      
  144.         case just == "R"
  145.             r := r + fwrite( WKSHandle, RIGHT_JUSTIFY )
  146.         case just == "L"
  147.             r := r + fwrite( WKSHandle, LEFT_JUSTIFY )
  148.         case just == "C"
  149.             r := r + fwrite( WKSHandle, CENTERED )
  150.         case just == "R"
  151.             r := r + fwrite( WKSHandle, REPEATING )
  152.     endcase
  153.  
  154. // actual textual string, len(ostr) chars //
  155.  
  156.     r := r + fwrite( WKSHandle, ostr, len(ostr) )
  157.  
  158. // Null termination, 1 char //
  159.  
  160.     r := r + fwrite( WKSHandle, chr(0), 1)
  161.  
  162. return( r == 11+len(ostr) )
  163.  
  164.  
  165.  
  166.  
  167. FUNCTION WKSwritenum( num, row, col )
  168.  
  169.     LOCAL r:=0
  170.  
  171. // Number Cell Header, 4 chars //
  172.  
  173.     r := fwrite( WKSHandle, WKS_NUMBERHDR )
  174.  
  175. // cell format, 1 char //
  176.  
  177.         r := r + fwrite( WKSHandle, STANDARD_FORMAT )
  178.  
  179. // Worksheet Co-Ordinates, 4 chars //
  180.  
  181.     r := r + WKScoord( row, col )
  182.  
  183. // Number converted to an ieee format, 8 chars //
  184.  
  185.     r := r + fwrite( WKSHandle, dec2ieee( num ) )
  186.  
  187. return( r == 17 )
  188.  
  189. FUNCTION WKScoord( row, col )
  190.  
  191.     LOCAL r:=0
  192.  
  193.     r := fwrite( WKSHandle, chr( col-1 )+chr(0)+chr( row-1 )+chr(0) )
  194.  
  195. return( r )
  196.  
  197. FUNCTION dec2ieee( num )
  198.  
  199.     LOCAL ieeea := { 0, 0, 0, 0, 0, 0, 0, 0 }, F, exponent, e1, e2, e3, ;
  200.           sign, i, part
  201.  
  202.     if num != 0
  203.  
  204.         sign := if(num<0, 1, 0)
  205.         if sign != 0
  206.             num := num * -1
  207.         endif
  208.         if log(num)/log(2)<0
  209.             exponent:=int(log(num)/log(2)-1)+1023
  210.         else
  211.             exponent:=int(log(num)/log(2))+1023
  212.         endif
  213.  
  214.         F := ( num / 2^(exponent-1023) - 1 ) * 2^52
  215.  
  216. // save exponent //
  217.  
  218.         e1 := int(exponent/256)
  219.         e2 := int((exponent-e1*256)/16)
  220.         e3 := exponent-e1*256-e2*16
  221.  
  222.         ieeea[8] := (sign*128)+e1*16+e2
  223.         ieeea[7] := e3*16
  224.         
  225. // save fraction //
  226.  
  227.         for i=6 to 0 step -1
  228.             part := int( F / 256^i )
  229.             ieeea[i+1] := ieeea[i+1] + part
  230.             F := F-part*256^i
  231.         next
  232.  
  233.     endif
  234.  
  235. RETURN( chr(ieeea[1])+chr(ieeea[2])+chr(ieeea[3])+chr(ieeea[4])+ ;
  236.     chr(ieeea[5])+chr(ieeea[6])+chr(ieeea[7])+chr(ieeea[8]) )
  237.